(* ===================================================================== *)
(** CDSMAKER : module integrant, fonction d'analyse de la net_list  
    construction du circuit CDS.
    @author Mathieu Barbin, Ocan SANKUR
    @version originale samedi 17 novembre 2007, current : mardi 29 juillet 2008 *)
(* ===================================================================== *)

(* ==================== *)
(*     Dependances      *)
(* ==================== *)
open BplibTypes
open Bplib
open Message
open ListMap
open Inputtools
open Circuit
(* ==================== *)

(* ===================================================================== *)
(** Construire un ensemble de chaine a partir d'une liste.
    le fold_left est tail-recursif, pas le right.*)
(* ===================================================================== *)
let stringSet_of_list = 
  List.fold_left (fun set x -> StringSet.add x set) StringSet.empty
(* ===================================================================== *)

exception NonDistincts of string

(* ===================================================================== *)
(** La meme fonction, mais raise NonDistincts si un element se repete ou 
    appartient a la premiere liste donnee *)
(* ===================================================================== *)
let stringSet_of_list_distincts interdit =
  let f set x = 
    if StringSet.mem x set || List.mem x interdit then raise (NonDistincts x)
    else StringSet.add x set in
  List.fold_left f StringSet.empty
(* ===================================================================== *)

(* ===================================================================== *)
(** Ajouter dans une Map toutes les liaisons d'une liste d'association *)
(* ===================================================================== *)
let add_list_StringMap = 
  let f_fold env (key, value) = StringMap.add key value env in
  List.fold_left f_fold 
(* ===================================================================== *)

(* ===================================================================== *)
(** Parser le fichier net_list, et detecter les erreurs de syntaxe *)
(* ===================================================================== *)
let net_list_of_file filename =
  try
    index_ligne_net_list := 1;
    let ic = open_in filename in
    let buff = Lexing.from_channel ic in
    let youpi = ParserNet.net_list LexerNet.lexem_list buff
    in
    begin
      (* message#read_net_list filename; *)
      close_in ic;
      youpi
    end
  with
  | Sys_error _ -> message#net_list_introuvable (module_name_of_filename filename) filename; 
                   failwith "w-friendly"
  | Parsing.Parse_error ->
      message#syntax_error filename (!index_ligne_net_list); 
      failwith "w-friendly"
  | Failure m -> 
      message#syntax_error_message m filename (!index_ligne_net_list); 
      failwith "w-friendly"
(* ===================================================================== *)

(* ===================================================================== *)
(** Creer une table d'arite initiale des primitives pour la verification 
    de l'arite des noeuds primitif dans le net list : nom , (entree, sortie) 
    au debut, aucune primitive de type ram et rom ( ajoutees apres )*)
(* ===================================================================== *)
let arite_primitive_initiale () = 
  let ll = 
    [
      "not",(Not, (1,1)); 
      "~",(Not, (1,1));
      "and",(Et, (2,1));
      "or",(Ou, (2,1));
      "id",(Id, (1,1));
      "xor",(Xor, (2,1));
      "mux",(Mux, (3,1));
      "reg",(Reg, (1,1));
      "Z",(Reg, (1,1));  
      "nreg",(NReg, (1,1));
      "nZ",(NReg, (1,1));
  (* version des registres avec un enable *)
      "regen",(Reg, (2,1));
      "Zen",(Reg, (2,1));
      "nregen",(NReg, (2,1));
      "nZen",(NReg, (2,1));
      "opt", (Opt, (0,1));
      "clock",(Clock, (0,1));  
      "gnd",(Gnd, (0,1));
      "vdd",(Vdd, (0,1))
    ]
  in add_list_StringMap StringMap.empty ll
(* ===================================================================== *)

(* ===================================================================== *)
(** Donner une idee du nombre de transistors pour un circuit *)
(* ===================================================================== *)
let transistors_of_primitif = function
  | Input | Output | Id -> 0 
  | Not                 -> 2 
  | Et | Ou             -> 6
  | Xor                 -> 8 
  | Mux                 -> 6
  | Rom _ | Ram _       -> 0
  | Reg                 -> 16 
  | NReg                -> 16 
  | Regr _              -> 0
  | Regt                -> 16 
  | Clock | Gnd | Vdd   -> 0
  | Opt                 -> 0
  | PipeNode _          -> 0
  | ExternalNode _      -> 0 

let transistors_of_circuit = 
  let f accu e = accu + (transistors_of_primitif e.noeud_type) in
  Array.fold_left f 0
(* ===================================================================== *)


(* ===================================================================== *)
(** Lire les infos d'une memoire en les filtrant si c'est d'un fichier.
    La convention du parser est que 0 designe une rom specifiee text et 
    1 designe une rom specifiee dans un fichier.
    Le parser-lexer effectue le filtrage sur les entrees text.*)
(* ===================================================================== *)
let read_code_brut_memoire file = function 
  | Counter              -> message#counter_for_memory file; failwith "w-friendly"
  | ArgFun _ | UnitFun _ -> message#metafun_for_memory file; failwith "w-friendly"
  | BinaryFile chaine    -> BoolArray.of_bin_file chaine
  | Text chaine          -> BoolArray.of_string chaine
  | File chaine -> 
      try
	BoolArray.of_asci_file chaine
      with
      | Sys_error _ -> message#rom_file_introuvable chaine; failwith "w-friendly"
(* ===================================================================== *)

(* ===================================================================== *)
(** Etant donné un code brut, il faut le decouper en mots correspondant
    aux valeurs lues dans une rom, ou une ram en initialisation. Si le code 
    est trop court, le reste est mis a false. 
    Si le code est trop long, on leve une erreur. *)
(* ===================================================================== *)
let tab_bits_of_code_brut name taille lg_mot code =  
  let len_attendue = taille * lg_mot and len_donnee = Array.length code in
  if len_donnee > len_attendue 
  then 
    begin
      message#rom_definition_trop_lg name len_attendue len_donnee;
      failwith "w-friendly"
    end
  else
    let ff i = 
      if i < len_donnee
      then code.(i)
      else false
    in 
    begin
      message#lecture_etat_memoire len_donnee len_attendue;
      (Bplib.init_matrix_linear taille lg_mot ff)
    end
(* ===================================================================== *)

(* ===================================================================== *)
(** Constructeur d'une fonction qui va mettre a jour un environnement des 
    primitives, et creer les valeurs des memoires ROM. Cette fonction 
    opere directement sur un tableau d'arite initial, et sur la premiere 
    composante du couple fourni par le parser c'est a dire sur la liste 
    des declarations des memoires. On rend aussi une table de declaration 
    pour faciliter l'exportation vers verilog *)
(* ===================================================================== *)
let add_ram_rom_factory () = 
  let index_rom = ref 0 
  and valeurs_memoires = Queue.create () 
  and table_export = Queue.create () in
  (* add_une_memoire : fonction auxiliaire qui rend la table des arites des 
     primitives dans laquelle on a ajoute la primitive memoire correspondant 
     a la declaration -> Utilisee avec un fold_left *) 
  let add_une_memoire macros arit declm = 
    let fichier = declm.fichier_dcl_m and line = declm.ligne_dcl_m and type_m = declm.type_dcl_m in
    let adresse, sortie = 
      try
	(eval_expr macros declm.arite_entree_dcl_m, 
	 eval_expr macros declm.arite_sortie_dcl_m)
      with
      | FreeVar x -> 
	  Message.message#free_meta_var fichier line x;failwith "w-friendly"
      | TypeClash m ->
	  Message.message#type_clash fichier line m; failwith "w-friendly"
    and des_etat = 
      match declm.description_entree_dcl_m with
      | Some (File f)       -> Some (File (meta_commande macros f))
      | Some (BinaryFile f) -> Some (BinaryFile (meta_commande macros f))
      | o -> o
    in
    match fichier, line, type_m, adresse, sortie, des_etat with
    | (fichier, line, ROM_decl name, adresse, sortie, Some code) ->
	let rom_name = Printf.sprintf "rom_%s" name in
	if StringMap.mem rom_name arit 
	then (message#definition_multiple_rom fichier line name; failwith "w_friendly")
	else 
	  begin
	    message#new_rom_type name adresse sortie;
	    let code_brut_rom = read_code_brut_memoire fichier code in
	    let taille_adr = 2 $$ adresse in
	    let code_complet = 
	      tab_bits_of_code_brut name taille_adr sortie code_brut_rom in 
	    (* construction du code complet a mettre dans la file *)
	    begin
	      let export = 
		{
		  fichier_dcl_m = fichier;
		  ligne_dcl_m = line;
		  type_dcl_m = ROM_decl name;
		  arite_entree_dcl_m = adresse;
		  arite_sortie_dcl_m = sortie;
		  description_entree_dcl_m = Some code_complet
		} in
	      Queue.add export table_export;
	      Queue.add code_complet valeurs_memoires;
	      incr(index_rom);
	      (* rendre la nouvelle table completee *)
	      (StringMap.add rom_name 
		 (Rom (name, (pred (!index_rom))), (adresse, sortie)) arit)
	    end
	  end
    | (fichier, line, RAM_decl name, adresse, sortie, code_option) ->
	let ram_name = Printf.sprintf "ram_%s" name in
	if StringMap.mem ram_name arit
	then (message#definition_multiple_ram fichier line name; failwith "w-friendly")
	else
	  let taille_adr = 2 $$ adresse in
	  let code_complet, description_code =
	    match code_option with
	    | None ->
		begin
		  message#new_ram_type_sans_init name adresse sortie;
		  (Bplib.init_matrix_linear taille_adr sortie (fun _ -> false), None) 
		end
	    | Some code -> 
		begin
		  message#new_ram_type name adresse sortie;
		  let code_brut_ram = read_code_brut_memoire fichier code in
		  let code_sortie = tab_bits_of_code_brut name taille_adr sortie code_brut_ram in
		  code_sortie, Some code_sortie
		end
	  in
	  (* completer la table d'export *)
	  let export =
	    {
	      fichier_dcl_m = fichier;
	      ligne_dcl_m = line;
	      type_dcl_m = RAM_decl name;
	      arite_entree_dcl_m = adresse;
	      arite_sortie_dcl_m = sortie;
	      description_entree_dcl_m = description_code
	    } in 
	  Queue.add export table_export;
	  (* rendre la nouvelle table completee *)
	  (StringMap.add ram_name (Ram (name, (adresse, sortie, code_complet)), 
				   (2*adresse + 1 + sortie, sortie)) arit)  
    | _ -> failwith "rom None, add_ram_rom cf parser"
  in 
  fun macros li env_init -> 
    begin
      let env_final = List.fold_left (add_une_memoire macros) env_init li in
      let len = Queue.length valeurs_memoires in
      let tab_rom = Array.init len (fun _ -> Queue.pop valeurs_memoires) in
      let len2 = Queue.length table_export in
      let tab_export = Array.init len2 (fun _ -> Queue.pop table_export) in
      tab_rom, env_final, tab_export
    end
(* ======= *)
(** fonction de traitement des declarations memoires du parser *)
(* ======= *)
let add_ram_rom_in_primitive = add_ram_rom_factory ()
(* ===================================================================== *)

(* Il y a 3 developpement du code : 

   - les boucles for
   - les imbrications des appels
   - l'inline final des fonctions
   
   Le developement des boucles for est codee dans inputtools.ml 
   Il doit etre fait avant la desimbrication. *)

(* Dans ce qui suit, on a besoin d'une gestion generique des freshs *)

(* ===================================================================== *)
(** Instance du type d'un appel de fonction dans la net_list
    Definie anterieurement sans parametre, ou une primitive *)
(* ===================================================================== *)
type type_appel = FctAnt of string | Prim of primitif
(* ===================================================================== *)

(* ===================================================================== *)
(** Environnement des fonctions de la net_list : 
    C'est une Map des descriptions des toutes les fonctions de la net_list *)
(* ===================================================================== *)
type fonction_description = 
{
  fichier : string;
  name : string;
  arite_entree : int;
  arite_sortie : int;
  variables_locales : string list;
  entrees_formelles : string list;
  sorties_formelles : string list;
  corps : (type_appel * string list * string list) list
}
(* ===================================================================== *)

(* ===================================================================== *)
(** La transformation utilisee pour les freshs dans la desimbrication est 
    int -> Simple #int#. A ne pas confondre avec $int$ qui est utilise
    dans l'inline des fonctions *)  
(* ===================================================================== *)
let transf_fresh_desimbriq i = Fresh i
(* ===================================================================== *)

(* ===================================================================== *)
(** Pendant la desimbrication, il est cense ne pas reste de variable libre
    dans les parametres. *)
(* ===================================================================== *)
let concat_parametre_name nom valeurs arguments_fonctionnels= 
  try
    let suff = List.fold_left (fun accu s -> accu^"["^(string_of_int s)^"]") "" valeurs in
    let args = List.fold_left (fun accu s -> accu^"_"^s) "" arguments_fonctionnels in
    Printf.sprintf "%s%s%s" nom suff args
  with
  | FreeVar x -> failwith "concat_parametre_name"
(* ===================================================================== *)

(* ===================================================================== *)
(** A la fin de la desimbriquation, on verifie qu'il ne reste pas de variable
    indexee qui n'appartiennent a aucune boucle, et pas d'appels parametres *)
(* ===================================================================== *) 
let check_end_desimbriq fichier arg : noeud_lineaire = 
  match arg with 
    | (line, BEBOP (call_name, parametres, arguments_fcts), apl_list1, apl_list2) ->
        begin
          match parametres, arguments_fcts with
            | [], [] -> (line, LocalCall call_name, apl_list1, apl_list2)
            | _, _ -> 
                Message.message#remove_parametres_incomplet fichier line;
                failwith "w-friendly"
        end
    | (line, EXTERNAL_BLOC (arg, _, _, Calcul _), _, _) ->
        failwith (Printf.sprintf "Ligne : %d $bloc_externe(\"%s\"...), il reste du calcul ??" line arg)
    | (line, EXTERNAL_BLOC (arg, meth, string_args, arite), apl_list1, apl_list2) ->
        (line, ExternalCall (arg, meth, string_args, arite), apl_list1, apl_list2 )
    | (line, PIPE (arg, Calcul _), _, _) ->
        failwith (Printf.sprintf "Ligne : %d pipe(\"%s\"...), il reste du calcul ??" line arg)
    | (line, PIPE (arg, arite), apl_list1, apl_list2) ->
        (line, PipeCall (arg, arite), apl_list1, apl_list2)
(* ===================================================================== *)

(* Analyse des fonctions de la net-list : inline final *)
(* ===================================================================== *)
(** La detection des cycles etant un peu sommaire (oui ou non), on ajoute
    une couche d'aide pour reperer les cycles : un cycle est forcement présent
    au niveau d'un bloc : dans ce cas, on fournit un affichage plus explicite *)
(* ===================================================================== *)
let string_of_typ = function
  | FctAnt s -> s
  | Prim p -> 
      (match p with
       | Id -> "id"
       | Not -> "not"
       | Et -> "and" 
       | Ou -> "or" 
       | Xor -> "xor" 
       | Mux -> "mux"
       | Rom _ -> "rom_?"
       | Ram _ -> "ram_?"
       | Reg | NReg 
       | Regr _ | Regt -> "reg" 
       | PipeNode (com, _, _) -> Printf.sprintf "pipe[\"%s\"]" com 
       | _ -> "?"
      )

(** Gestion des cycles : La technique utilisee est de proposer des points d'entree
    sur le code qui ne sont pas forcement des cycles et de les montrer que si 
    on detecte un cycle global *)
(* on met les indications dans la file *)
let indications_cycle = Queue.create ();;
let add_indications_cycle s = Queue.push s indications_cycle;;

let detect_cycle_in_fonction fd = (* fonction description *)
  let vars = fd.variables_locales@fd.entrees_formelles@fd.sorties_formelles in
  let visited = ref StringSet.empty and parents = ref [] in
  let liaisons =
    (* parcours du corps pour construire les arretes *)
    let rec aux accu = function
      | [] -> accu
      | (typ, ent, sor)::q ->
	  begin
	    match typ with
	    | Prim Reg | Prim NReg | Prim (Regr _) | Prim Regt -> aux accu q
	    | _ ->
		(* chaque sortie depend de toutes les entrees *)
		(* chaque sortie se trouve uniquement la : (branchement conflictuels) *)
		let f_fold acc s =
		  StringMap.add s (typ, ent) acc
		in aux (List.fold_left f_fold accu sor) q
	  end
    in aux StringMap.empty fd.corps 
  in
  let rec f_iter v =
    if List.exists (fun (_, u) -> u=v) (!parents)
    then 
      begin
	add_indications_cycle (Printf.sprintf "[ !! ] Fonction %s :\n" fd.name);
	let rec affiche_cycle accu last = function
	  | [] -> List.iter (fun s -> add_indications_cycle s) accu
	  | (typ, u)::q ->
	      begin
		let s = (Printf.sprintf "%s\n" (Printf.sprintf "  ..%s.. = ..%s(..%s..)" u (string_of_typ typ) last)) in
		if u = v 
		then List.iter (fun s -> add_indications_cycle s) (s::accu)
		else affiche_cycle (s::accu) u q
	      end
	in affiche_cycle [] v (!parents)
      end
    else
      if StringSet.mem v (!visited)
      then ()
      else (dfs v)
  and dfs v =
    visited := StringSet.add v (!visited);
    (* iteration sur les voisins : ic sur les entrees dont dependent cette sortie *)
    begin
      try
	let typ, ent = StringMap.find v liaisons in
	begin
	  parents := (typ,v)::(!parents);
	  List.iter f_iter ent;
	  parents := List.tl (!parents)
	end
      with
      | Not_found -> ()
    end
  in
  List.iter f_iter vars;
  fd
(* ===================================================================== *)

(* ===================================================================== *)
(** Creer la description d'une fonction en effectuant des verifications 
    de contextes, a partir des declarations des fonctions de la net-list,
    une fois qu'on a enlever les boucles for et qu'on a desimbrique *)
(* ===================================================================== *)
let creer_fonction arite_prim env (fd:fonction_debouclee) =  
  let (filename, fct_line, attributs, name, entree_list, sortie_list, unused, corps_c) =
    fd.fichier_dcl_f,
    fd.ligne_dcl_f,
    fd.attribut_dcl_f,
    fd.nom_dcl_f,
    (* ICI, ce qui nous interresse est la premiere composante, pas les infos *)
    fst fd.entrees_dcl_f,
    fst fd.sorties_dcl_f,
    fst fd.unused_dcl_f,
    fd.corps_dcl_f (* FIXME : it is just to see *)
  in
  if name = "_" 
  then (message#utilisation_any filename fct_line name; failwith "w-friendly")
  else
  if StringMap.mem name arite_prim 
  then (message#redefinition_prim filename fct_line name; failwith "w-friendly")
  else 
  if StringMap.mem name env
  then (message#definition_multiple_net filename fct_line name; failwith "w-friendly")
  else
  let ensemble_entree, ensemble_sortie = 
    try
      stringSet_of_list_distincts ["_"] entree_list, 
      stringSet_of_list_distincts ["_"] sortie_list 
    with
    | NonDistincts s when s = "_" -> 
	message#utilisation_any filename fct_line s; failwith "w-friendly"
    | NonDistincts s -> message#multi_utilisation_var filename fct_line s; failwith "w-friendly"
  in
  let unused_decl = stringSet_of_list ("_"::unused) in
  let variables_spec = StringSet.union ensemble_entree ensemble_sortie in
  (* creer les ensembles des variables utilisees comme entree, comme sorties *)
  (* une variable ne peut pas etre branchée a deux sortie de primitives, 
     sauf si c'est "_" qui n'est pas utilisee par construction *)
  let f_fold = fun (set_e,set_s) (_, _, (e_l, _), (s_l, _)) -> 
    (List.fold_left (fun set e -> StringSet.add e set) set_e e_l),
    (List.fold_left (fun set s -> 
		       if StringSet.mem s set && s <> "_"
		       then 
			 begin
			   message#branchement_multiple filename name s;
			   failwith "w-friendly"
			 end
		       else StringSet.add s set) set_s s_l)
  in 
  let (entrees_appel,sorties_appel) = List.fold_left f_fold (StringSet.empty,StringSet.empty) corps_c in 
  let variables_locales = StringSet.diff (StringSet.union entrees_appel sorties_appel) variables_spec in
  begin
    (* Warning et Error *)
    let variable_inutile x = 
      (* verifier en meme temps si une variable declaree comme unused est utilisee *)
      if (StringSet.mem x entrees_appel)
      then 
	if (StringSet.mem x unused_decl)
	then message#variable_inutile_utilisee filename name x
	else ()
      else
	if (StringSet.mem x unused_decl) || (x.[0] = '?')
	then ()
	else message#variable_inutile filename name x
    and variable_non_assignee x =
      if not (StringSet.mem x sorties_appel)
      then message#variable_non_assignee filename name x
      else ()
    and entree_modifiee x =
      if (StringSet.mem x sorties_appel)
      then message#entree_modifiee filename name x
      else ()
    in 
    begin
      (* Warning : *)
      (* si une variable local ne sert a rien *)
      StringSet.iter variable_inutile variables_locales;
      (* si un argument de la fonction ne sert a rien *)
      StringSet.iter variable_inutile ensemble_entree;
      (*  Error   *)
      (* si l'ensemble des entrees et des sorties ne sont pas disjoints *)
      (* par l'absurde : comme ce serait une sortie, elle doit etre modifiee
	 donc c'est qu'une entree est modifiee : redondant *)
      (* si une entree de la fonction est modifiee *)
      StringSet.iter entree_modifiee ensemble_entree;
      (* si une sortie n'est pas specifiee *)
      StringSet.iter variable_non_assignee ensemble_sortie;
      (* si une variable local est observee mais pas assignee *)
      StringSet.iter variable_non_assignee variables_locales;


      (* Creation du corps en verifiant les arites *)

      let corps = 
	(* Le corps d'une fonction est par convention la liste des appels. *)
	(* On construit un appel effectif (une ligne de base de la net-list). *)
	(* C'est un triplet (type_appel, entrees_effct, sorties_effct) *)
	(* WARNING call name devient de type LocalCall ou PipeCall *)
	let make_appel ((line, call, (ent, _), (sor, _)):noeud_lineaire) = 
	  begin
            match call with
            | PipeCall (syscom, arit) -> 
                begin
                  match arit with
                  | Infere -> 
                      (* maintenant il est possible d'inferer, puisque'on 
                         est en presence d'entrees-sorties developpees *)
                      (* FIXME : traitement string avec meta vars : "myexe $(CK)" *)
                      (Prim (PipeNode (syscom, List.length sor, ref (-1))), ent, sor)
		  | Resultat i ->
                      (* FIXME : doit on faire la verif ? *)
		      (
                        if i <> List.length sor then failwith "Type checking pipe error"
                        else (Prim (PipeNode (syscom, i, ref (-1))), ent, sor)
		      )
		  | Calcul _ ->
                      failwith "Pourquoi encore un calcul a cette etape ?"
                end
	      | ExternalCall (bloc_name, meth, string_args, arit) -> 
                  begin
                    match arit with
                    | Infere -> 
                        (* maintenant il est possible d'inferer, puisque'on 
                           est en presence d'entrees-sorties developpees *)
                        (* traitement string avec meta vars : "myexe $(CK)" est fait dans mem_and_env_of_file . traite_pile *)
                        (Prim (ExternalNode (filename, line, bloc_name, meth, string_args, List.length sor, ref (-1))), ent, sor)
		    | Resultat i ->
                        (* FIXME : doit on faire la verif ? *)
			(
                          if i <> List.length sor then failwith "Type checking pipe error"
                          else (Prim (ExternalNode (filename, line, bloc_name, meth, string_args, i, ref (-1))), ent, sor)
			)
		    | Calcul _ ->
                        failwith "Pourquoi encore un calcul a cette etape ? (external)"
                  end    
              | LocalCall call_name ->
                (  
	          (* d'abord, on voit si c'est un appel a une primitive *)
	          try
	            let infos_primitive = StringMap.find call_name arite_prim in
	            (
		      match infos_primitive with
		        | (prim, (e, s)) -> 
		            if (e <> (List.length ent)) 
		            then message#arite_entree_prim filename line name call_name e
		            else
		              if (s <> (List.length sor))
		              then message#arite_sortie_prim filename line name call_name s
		              else ();
		            (Prim prim, ent, sor)
	            )
	          with
	              (* Ce n'est pas une primitive *)
	            | Not_found ->
		        begin
		          (* Alors essayons de voir si c'est un appel de fonction *) 
		          try
		            let desAnt = StringMap.find call_name env in
		            let e = desAnt.arite_entree
		            and s = desAnt.arite_sortie 
		            in
		            begin
		              if (e <> (List.length ent)) 
		              then message#arite_entree_fct filename line name call_name e
		              else
			        if (s <> (List.length sor))
			        then message#arite_sortie_fct filename line name call_name s
			        else ();
		              (FctAnt call_name, ent, sor)
		            end
		          with
		              (* Sinon, il s'agit d'un appel a une fonction non definie *)
		            | Not_found ->
		                begin
			          message#fct_non_declaree filename line name call_name;
			          failwith "w-friendly"
		                end
		        end
                )
	  end
	in List.map make_appel corps_c

      in
      (detect_cycle_in_fonction
	 {
	   fichier = filename;
	   name = name;
	   arite_entree = List.length entree_list;
	   arite_sortie = List.length sortie_list;
	   variables_locales = StringSet.elements variables_locales;
	   entrees_formelles = entree_list;
	   sorties_formelles = sortie_list;
	   corps = corps
	 }
      )
    end
  end
(* ===================================================================== *)

(*
let string_of_corps = 
  let aux (line, call, ent, sor) =
    let string_of_list = List.fold_left (fun accu n -> accu^", "^n) "" in
    match call with 
      | PipeCall (syscom, arit) -> 
          let sarit = 
            match arit with
              | Infere -> "inf"
              | Calcul _ -> "cal"
              | Resultat i -> string_of_int i
          in
          Printf.sprintf "%s = pipe[%s](\"%s\",%s);\n" (string_of_list sor) sarit syscom (string_of_list ent)
      | LocalCall s -> Printf.sprintf "%s = %s(%s);\n" (string_of_list sor) s (string_of_list ent)
  in 
  List.fold_left (fun accu n -> accu^(aux n)) "";;
*)
(* ===================================================================== *)
(** Creer l'environnement complet de la net_list a partir du tableau d'arite
    des primitives, et de la liste des declarations de fonctions fournie 
    par le parser (une fois triee topologiquement) *)  
(* ===================================================================== *)
let creer_environnement arite_primitive default_main list = 
  let new_fct_des = creer_fonction arite_primitive in
  let f_fold (env,last) fct_debouclee =
    let name = fct_debouclee.nom_dcl_f in
    ((StringMap.add name (new_fct_des env fct_debouclee) env), 
     if List.mem "main" (List.map String.lowercase fct_debouclee.attribut_dcl_f) 
     then name
     else last)
  in 
  let environnement_of_list = function
    | [] -> message#circuit_vide; failwith "w-friendly"
    | list -> List.fold_left f_fold (StringMap.empty, default_main) list
  in
  begin
    message#analyse_net_list;
    environnement_of_list list (* repeat list : w-friendly *)
  end
(* ===================================================================== *)

(* ===================================================================== *)
(** Interpreter une definition brute d'un bloc externe *)
(* ===================================================================== *)
let evaluate_bloc_string env bloc =
  let init_def_meta_commande env  = function
    | DEF_METHOD_BLOC (a, (att, b)) -> DEF_METHOD_BLOC ((meta_commande env a), (att, meta_commande env b))
    | INIT_MESSAGE_BLOC s -> INIT_MESSAGE_BLOC (meta_commande env s)
  in
  try
    let list_melangee = desucre_declaration init_def_meta_commande env bloc.raw_init_messages_def_method in
    let init_messages, methods =
      let rec aux = function
	| (DEF_METHOD_BLOC (a, infos))::q -> (match aux q with init, def -> init, ((a, infos)::def))
	| (INIT_MESSAGE_BLOC s)::q -> (match aux q with init, def -> (s::init), def)
	| [] -> [], []
      in aux list_melangee
    in
    {
      attributs_bloc_ext = bloc.raw_attributs;
      fichier_bloc_ext = bloc.raw_fichier_bloc_ext;
      ligne_bloc_ext = bloc.raw_ligne_bloc_ext;
      nom_bloc_ext = bloc.raw_nom_bloc_ext;
      init_messages = init_messages;
      methods = methods;
      command_shell = meta_commande env bloc.raw_command_shell
    }
  with
  | SyntaxError com -> 
      Message.message#commande_syntax_error_external bloc.raw_fichier_bloc_ext bloc.raw_nom_bloc_ext bloc.raw_ligne_bloc_ext com;
      failwith "w-friendly"
  | FreeVar v ->
      Message.message#free_meta_var_external bloc.raw_fichier_bloc_ext bloc.raw_nom_bloc_ext bloc.raw_ligne_bloc_ext v;
      failwith "w-friendly"
  | TypeClash m ->
      Message.message#type_clash_external bloc.raw_fichier_bloc_ext bloc.raw_ligne_bloc_ext bloc.raw_nom_bloc_ext m;
      failwith "w-friendly"
(* ===================================================================== *)

(* ===================================================================== *)
(** Combiner les arguments partiels avec les effectifs pour former la liste 
    de liaison fonctionnelle : cf arguments fonctionnels.
    @raise LengthError si les effectifs sont trop peu nombreux *)
(* ===================================================================== *)
let combine_liaisons_with_partial formels partials effectifs =
  let f_fold_map reserve expected_formel =
    let new_reserve, assoc =
      try
	reserve, List.assoc expected_formel partials
      with
      | Not_found ->
	  begin
	    match reserve with
	    | t::q -> q, t
	    | _ -> raise LengthError
	  end
    in  
    new_reserve, (expected_formel, assoc)
  in list_fold_map f_fold_map effectifs formels 
(* ===================================================================== *)

	
(* Voici une fonction qui fait un peu peur quand on la regarde comme ca en passant *)
(*
  Quand on la regarde plus en détail, on hésite entre dire : 
  - IT IS A BAD BIG BLOB !
  - du vaudou ocaml mutuellement recursif ?
*) 

(* ===================================================================== *)
(** A partir du nom du fichier de la net_list, creer les macro-define, 
    supprimer toutes les boucles, expansier les net-variables vectorielles, 
    creer la table des memoires, et la liste des fonctions avant de creer
    l'environnement fonctionnel complet de la net-list. *)  
(* ===================================================================== *)
let analyse_net_list arite_primitive_initiale filename =
  let module_name = module_name_of_filename filename in
  let files_bebop = ref [filename] in
  let modules_bebop = ref StringSet.empty in
  Message.message#set_net_list module_name;
  match net_list_of_file filename with
  | include_decl, macros_decl_main, mems_decl_main, externals_blocs_decl_non_interpretes_main, fcts_decl_main, default_main ->  
      (* On concatene simplement les parsages de tous les fichiers *)
      modules_bebop := StringSet.add module_name !modules_bebop;
      let modules_queue = Queue.create () in
      List.iter (fun t -> Queue.add t modules_queue) include_decl;
      let macros_decl, mems_decl, externals_blocs_decl_non_interpretes, fcts_decl =
        let a, b, c, d = 
          let rec f_iter_queue (mac, mem, ext, fcts) =
	    if Queue.is_empty modules_queue then (mac, mem, ext, fcts)
	    else 
	      let incl = Queue.pop modules_queue in
              match incl.type_include with
              | CurrentDir file ->
		  let module_name = module_name_of_filename file in
		  if StringSet.mem module_name !modules_bebop then f_iter_queue (mac, mem, ext, fcts)
		  else
                    begin
		      modules_bebop := StringSet.add module_name !modules_bebop;
		      files_bebop := file::(!files_bebop);
		      (* FIXED : prend le nom capitalize du fichier, FIXME : pour en prefixer les fonctions *)
                      Message.message#including_file file;
                      Message.message#set_net_list module_name;
                      let (new_incl, mac2, mem2, ext2, fcts2, _) = net_list_of_file file in
		      List.iter (fun t -> Queue.add t modules_queue) new_incl;
		      (* List.iter (prefixe_name_with_module module_name) fcts2; *)
                      f_iter_queue (mac2@mac, mem2@mem, ext2@ext, fcts2@fcts)
                    end 
              | BebopDir file ->
                  begin
                    try
                      let rfile = Printf.sprintf "%s/boplibs/%s" (Unix.getenv "BEBOPDIR") file in
		      let module_name = module_name_of_filename file in
		      if StringSet.mem module_name !modules_bebop then f_iter_queue (mac, mem, ext, fcts)
		      else
			begin
			  modules_bebop := StringSet.add module_name !modules_bebop;
			  files_bebop := file::(!files_bebop);
			  Message.message#including_module module_name;
			  Message.message#set_net_list module_name;
			  let (new_incl, mac2, mem2, ext2, fcts2, _) = net_list_of_file rfile in
			  List.iter (fun t -> Queue.add t modules_queue) new_incl;
			  (* List.iter (prefixe_name_with_module module_name) fcts2; *)
			  f_iter_queue (mac2@mac, mem2@mem, ext2@ext, fcts2@fcts)
			end
                    with
                    | Not_found -> 
                        Message.message#not_found_bebop_dir;
                        failwith "w-friendly"
                  end   
          in
          f_iter_queue ([], [], [], [])
        in (a@macros_decl_main, b@mems_decl_main, c@externals_blocs_decl_non_interpretes_main, d@fcts_decl_main)
      in
      let module_name = module_name_of_filename filename in
      Message.message#set_net_list module_name; 
      Message.message#top_level module_name filename;
      (* on ajoute une variable pour connaitre l'OS sur lequel on s'execute *)
      let current_os = 
	{
	  fichier_macro = "Bopsimu-Default";
	  ligne_macro = 0;
	  nom_macro = "CURRENT_OS";
	  corps_macro = 
	    match Sys.os_type with
	    | "Unix" -> DefInt (CST 0)
	    | "Win32" -> DefInt (CST 1)
	    | _ -> DefInt (CST 2)
	} in
      let macros = env_macros_of_macros_decl (current_os::macros_decl) in
      let externals_blocs_decl = List.map (fun (nom, decl) -> (nom, evaluate_bloc_string macros decl)) externals_blocs_decl_non_interpretes in
      let memory, table_arite_completee, table_export_memoires =
	add_ram_rom_in_primitive macros mems_decl arite_primitive_initiale 
      in
      (* On va expancier toutes les fonctions dont on a besoin *)
      (* On travaille par effet de bord sur un environnement de fonctions
	 parametrees et sur une pile des fonctions debouclées, et 
	 déparametrées *)
      let fresh, _ = fresh_fct_factory transf_fresh_desimbriq in
      let fresh_sortie_decoree arite =
      	let sortie_list = list_init (fun _ -> fresh ()) arite in
	let f_map = function
	  | Fresh i -> Printf.sprintf "#%d#" i
	  | _ -> failwith "fresh_sortie_decoree"
	in 
	List.map f_map sortie_list, sortie_list
      in
      let pile_des_fonctions = Stack.create () in
      let fonctions_parametrees = ref StringMap.empty in
      let table_arite_sortante_fonctions = ref StringMap.empty in
      (* Desimbriquer les appels *)
      let rec specialiser_fonction_parametree spe = (* fichier liaisons line_appel fct_appel name valeurs_affectees *) 
	(* va empiler la bonne fonction dans la pile des fonctions *)
	message#specialisation spe.spe_fichier spe.spe_line_appel spe.spe_fct_appel spe.spe_name spe.spe_valeurs_affectees_param spe.spe_valeurs_affectees_args_fcts;
	try 
	  begin
	    let dp = StringMap.find spe.spe_name (!fonctions_parametrees) in
	    let param_list, args_fcts_list, decl_fun = dp.dp_params_formels, dp.dp_args_fcts_formels, dp.dp_declaration in
	    let arite_param = List.length param_list in
	    let arite_args_fcts = List.length args_fcts_list in
	    (* Verification de l'arite des parametres de l'appel *)
	    if arite_param <> List.length spe.spe_valeurs_affectees_param
	    then
	      begin
		message#arite_parametres_fct spe.spe_fichier spe.spe_line_appel spe.spe_name arite_param;
		failwith "w-friendly"
	      end
	    else ();
	    (* Verification de l'arite des arguments optionnels de l'appel *)
	    if arite_args_fcts <> List.length spe.spe_valeurs_affectees_args_fcts
	    then
	      begin
		message#arite_args_fct spe.spe_fichier spe.spe_line_appel spe.spe_name arite_args_fcts;
		failwith "w-friendly"
	      end
	    else ();
	    begin
	      let new_liaisons = List.combine param_list (List.map (fun v -> EnvInt v) spe.spe_valeurs_affectees_param) in
	      let liaisons_fonctionnelles = List.combine args_fcts_list spe.spe_valeurs_affectees_args_fcts in
	      let spec_name = concat_parametre_name decl_fun.nom_dcl_f spe.spe_valeurs_affectees_param spe.spe_valeurs_affectees_args_fcts in
	      let spec_decl = 
		{
		  fichier_dcl_f = decl_fun.fichier_dcl_f;
		  ligne_dcl_f = decl_fun.ligne_dcl_f;
		  attribut_dcl_f = decl_fun.attribut_dcl_f;
		  nom_dcl_f = spec_name;
		  entrees_dcl_f = decl_fun.entrees_dcl_f;
		  sorties_dcl_f = decl_fun.sorties_dcl_f;
		  unused_dcl_f = decl_fun.unused_dcl_f;
		  corps_dcl_f = decl_fun.corps_dcl_f
		} in
	      preprocess (new_liaisons@(spe.spe_liaisons)) liaisons_fonctionnelles (STANDARD spec_decl)
	    end
	  end
	with
	| Not_found ->  
	    begin
	      message#fct_parametree_non_declaree spe.spe_fichier spe.spe_line_appel spe.spe_fct_appel spe.spe_name;
	      failwith "w-friendly"
	    end 
     (* la on passe d'une liste de (variables_decorees noeud list) --> noeud_lineaire list *)
      and corps_desimbrique_of_corps fichier where_fonction liaisons liaisons_fonctionnelles (corps:(variables_decorees Inputtools.noeud) list) 
	  : noeud_lineaire list =
	(* Environnement fonctionnnel du meme type que liaisons, pour concatener *)
	let environnement_fonctionnel = List.map (fun (ind, va) -> (ind, EnvString va)) liaisons_fonctionnelles in
	let concat_variables_decorees (a, b) (c, d) : variables_decorees = (a@c, b@d) in 
	let appels_desimb_of_appel_imb noeud =
	  let pile = Stack.create () in
	  let file_appel = Queue.create () in
	  (* FIXME : passer en terminale avec un couple d'accu de type variables_decorees *)
	  let rec map_imb_list line accu (imb:(variables_decorees imbrication) list) = match imb with 
	  | [] -> accu
	  | (NET_VARS (a, b))::q -> map_imb_list line (concat_variables_decorees accu (a, b)) q 
	      (* assume @ : s a tres peu d'elements (en general 1) *)
	  | (IMB (ligne_imb, BEBOP (call_imb_brut, parametres_list, arguments_fonctionnels_list), imb_list))::q ->
	      (* on a ajoute dans l'environnement toutes les fonctions dont 
		 on a besoin parmi les parametrees *)
	      (* la convention, est qu'on a ajoute ces fonctions dans 
		 la map, avec pour cle la chaine concatenee avec les 
		 bonnes valeurs *)
	      let valeurs_parametres_list, valeurs_arguments_fonctionnels_list = 
		try
		  List.map (eval_expr liaisons) parametres_list, 
		  List.map (eval_arg_fct (environnement_fonctionnel@liaisons)) arguments_fonctionnels_list
		with
		| SyntaxError com -> 
		    Message.message#string_arg_syntax_error fichier ligne_imb com;
		    failwith "w-friendly"
		| FreeVar x ->   
		    begin
		      Message.message#free_meta_var fichier ligne_imb x;
		      failwith "w-friendly"
		    end
		| TypeClash m ->
		    begin
		      Message.message#type_clash fichier ligne_imb m;
		      failwith "w-friendly"
		    end
	      in
	      (* Au cas ou call_imb_incomplet est un argument fonctionnel, il faut le remplacer par sa valeur effective *)
	      (* ensuite, on peut ajouter les parametres, et les arguments fonctionnels eux-même  *)
	      let call_imb_incomplet = subst_fonctionnelle liaisons_fonctionnelles call_imb_brut in 
	      let call_imb = concat_parametre_name call_imb_incomplet valeurs_parametres_list valeurs_arguments_fonctionnels_list in
   		(* trouver l'arite sortante de call_imb *)
		(* 1) si c'est une primitive *)
		let arite_sortie =  
		  begin
		    try
		      match StringMap.find call_imb table_arite_completee with
		      | (_,(_, s)) -> s
		    with
		      (* Ce n'est pas une primitive *)
		    | Not_found ->
			(* Alors essayons de voir si c'est un appel de fonction standard *) 
			try
			  StringMap.find call_imb (!table_arite_sortante_fonctions) 
			with
			  (* Sinon, il s'agit d'un appel a une fonction non definie *)
			| Not_found -> 
			    (* Alors, il est possible que ce soit un appel a une fonction
			       parametree, a part si il n'y a pas de parametres *)
			    (
			      match valeurs_parametres_list, valeurs_arguments_fonctionnels_list with
			      | [], [] ->
				  begin
				    message#fct_non_declaree fichier ligne_imb where_fonction call_imb_incomplet;
				    failwith "w-friendly"
				  end
			      | _, _ ->
				  begin
				    (* il faut specialiser la fonction parametree, puisqu'on en a besoin *)
				    let spe = 
				      {
					spe_fichier = fichier;
					spe_liaisons = liaisons;
					spe_line_appel = ligne_imb;
					spe_fct_appel = where_fonction;
					spe_name = call_imb_incomplet;
					spe_valeurs_affectees_param = valeurs_parametres_list;
					spe_valeurs_affectees_args_fcts = valeurs_arguments_fonctionnels_list
				      }
				    in
				    specialiser_fonction_parametree spe; 
				    try
				      StringMap.find call_imb (!table_arite_sortante_fonctions)
				    with
				    | Not_found -> failwith "Qui ne fait pas son boulot ? (cdsmaker)"
				  end
			    )
		  end
		in
		let sortie_decoree = fresh_sortie_decoree arite_sortie in
		begin
                  (* FIXED *)
                  (* Printf.fprintf stderr "PUSH %s + " call_imb; *)
                  (* prerr_newline (); *)
		  Stack.push (ligne_imb, BEBOP (call_imb, [], []), imb_list, sortie_decoree) pile;
		  map_imb_list ligne_imb (concat_variables_decorees accu sortie_decoree) q
		    (* assume @ : sortie_decoree a peu d'elements *) 
		end

            (* fin du cas bebop imbrique *)

            | (IMB (ligne_imb, PIPE (exe, exp_arit_nature), imb_list))::q ->  
                let new_exe, arite_sortante_pipe = 
                  try
		    meta_commande liaisons exe, 
                    (
                      match exp_arit_nature with
                      | Resultat entier -> entier
                      | Calcul exp_arit -> eval_expr liaisons exp_arit
                      | Infere -> (Message.message#pipe_imbrique_arite_probleme fichier ligne_imb exe; failwith "w-friendly")
                    )
                  with 
		  | SyntaxError com ->
		      begin
			Message.message#string_arg_syntax_error fichier ligne_imb com;
			failwith "w-friendly"
		      end
                  | FreeVar x ->   
		      begin
			Message.message#free_meta_var fichier ligne_imb x;
			failwith "w-friendly"
		      end
		  | TypeClash m ->
		      begin
			Message.message#type_clash fichier ligne_imb m;
			failwith "w-friendly"
		      end
		in
		let sortie_decoree = fresh_sortie_decoree arite_sortante_pipe in
		begin
		  Stack.push (ligne_imb, PIPE (new_exe, (Resultat arite_sortante_pipe)), imb_list, sortie_decoree) pile;
		  map_imb_list ligne_imb (concat_variables_decorees accu sortie_decoree) q
		    (* assume @ : sortie_list a tres peu d'elements *)
		end
		  
          (* fin du cas pipe imbrique *)

	    | (IMB (ligne_imb, EXTERNAL_BLOC (bloc_name, meth, string_args, exp_arit_nature), imb_list))::q ->  
                let new_meth, new_string_args, arite_sortante_external = 
                  try
		    (
		      match meth with
		      | None -> None
		      | Some m -> Some (ref (meta_commande liaisons (!m)))
		    ),
		    (
		      let f_map s = meta_commande liaisons s
		      in List.map f_map string_args
		    ),
                    (
                      match exp_arit_nature with
                      | Resultat entier -> entier
                      | Calcul exp_arit -> eval_expr liaisons exp_arit
                      | Infere -> (Message.message#external_imbrique_arite_probleme fichier ligne_imb bloc_name; failwith "w-friendly")
                    )
                  with 
		  | SyntaxError com ->
		      begin
			Message.message#commande_syntax_error fichier ligne_imb com;
			failwith "w-friendly"
		      end
                  | FreeVar x ->   
		      begin
			Message.message#free_meta_var fichier ligne_imb x;
			failwith "w-friendly"
		      end
		  | TypeClash m ->
		      begin
			Message.message#type_clash fichier ligne_imb m;
			failwith "w-friendly"
		      end
		in
		let sortie_decoree = fresh_sortie_decoree arite_sortante_external in
		begin
		  Stack.push (ligne_imb, EXTERNAL_BLOC (bloc_name, new_meth, new_string_args, (Resultat arite_sortante_external)), imb_list, sortie_decoree) pile;
		  map_imb_list ligne_imb (concat_variables_decorees accu sortie_decoree) q
		    (* assume @ : sortie_list a tres peu d'elements *)
		end
		  
          (* fin du cas external imbrique *)

	  and traite_pile () =
	    if Stack.is_empty pile
	    then ()
	    else 
              begin
                match Stack.pop pile with
		  (* Cas BEBOP *)
                  | (line, BEBOP (call_name_brut, parametres_list, arguments_fonctionnels_list), imb_list, sorties) ->
                      (* Printf.fprintf stderr "pop %s + " call_name; prerr_newline (); *)
	              let entrees = map_imb_list line ([], []) imb_list in
	              begin 
		        let valeurs_parametres_list, valeurs_arguments_fonctionnels_list = 
		          try
		            List.map (eval_expr liaisons) parametres_list,
			    List.map (eval_arg_fct (environnement_fonctionnel@liaisons)) arguments_fonctionnels_list
		          with
			  | SyntaxError com -> 
			      Message.message#string_arg_syntax_error fichier line com;
			      failwith "w-friendly"
		          | FreeVar x ->   
		              begin
			        Message.message#free_meta_var fichier line x;
			        failwith "w-friendly"
		              end
			  | TypeClash m ->
			      begin
				Message.message#type_clash fichier line m;
				failwith "w-friendly"
			      end 
		        in
			(* Substitution par argument fonctionnel *)
			let call_name = subst_fonctionnelle liaisons_fonctionnelles call_name_brut in
		        let real_call_name = concat_parametre_name call_name valeurs_parametres_list valeurs_arguments_fonctionnels_list in
		        begin
		          if ((StringMap.mem real_call_name table_arite_completee) || (StringMap.mem real_call_name (!table_arite_sortante_fonctions)))
		          then () (* c'est qu'il s'agit d'un appel non parametre, ou deja traite *)
		          else 
			    (* s'il y a des parametres, c'est qu'il faut essayer de specialiser *)
			    (
			      match valeurs_parametres_list, valeurs_arguments_fonctionnels_list with
			      | [], [] -> 
				  begin
				    message#fct_non_declaree fichier line where_fonction call_name;
				    failwith "w-friendly" 
				  end
			      | _, _ -> 
				  begin
				    (* il faut essayer de specialiser, puisqu'on en a besoin *)
				    let spe = 
				      {	
					spe_fichier = fichier;
					spe_liaisons = liaisons;
					spe_line_appel = line;
					spe_fct_appel = where_fonction; (* fichier ? *)
					spe_name = call_name;
					spe_valeurs_affectees_param = valeurs_parametres_list;
					spe_valeurs_affectees_args_fcts = valeurs_arguments_fonctionnels_list
				      }
				    in
				    specialiser_fonction_parametree spe
				  end
			    );
		          Queue.add (line, BEBOP (real_call_name,[], []), entrees, sorties) file_appel;
		          traite_pile ()
		        end
	              end

		  (* Cas pipe *)
                  | (line, PIPE (syscom, exp_arit_nature), imb_list, sorties) ->
		      let commande = unraise_meta_commande fichier line liaisons syscom
		      in
                      let entrees = map_imb_list line ([], []) imb_list in
                      let arite_sortante_pipe = 
                        try
                          (
                            match exp_arit_nature with
                              | Resultat entier -> Resultat entier
                              | Calcul exp_arit -> Resultat (eval_expr liaisons exp_arit)
                              | Infere -> Infere 
                          )
                        with  
                          | FreeVar x ->   
		              begin
			        Message.message#free_meta_var fichier line x;
			        failwith "w-friendly"
		              end
			  | TypeClash m ->
			      begin
				Message.message#type_clash fichier line m;
				failwith "w-friendly"
			      end	
                      in
                      Queue.add (line, PIPE (commande, arite_sortante_pipe), entrees, sorties) file_appel;
                      traite_pile ()

		  (* Cas external *)
		  | (line, EXTERNAL_BLOC (bloc_name, meth, string_args, exp_arit_nature), imb_list, sorties) ->
                      let new_meth, new_string_args = 
			(
			  match meth with
			  | None -> None
			  | Some m -> Some (ref (unraise_meta_commande fichier line liaisons !m))
			),
			(
			  let f_map s = unraise_meta_commande fichier line liaisons s in
			  List.map f_map string_args
			)
		      in
                      let entrees = map_imb_list line ([], []) imb_list in
                      let arite_sortante_pipe = 
                        try
                          (
                            match exp_arit_nature with
                            | Resultat entier -> Resultat entier
                            | Calcul exp_arit -> Resultat (eval_expr liaisons exp_arit)
                            | Infere -> Infere 
                          )
                        with  
                        | FreeVar x ->   
		            begin
			      Message.message#free_meta_var fichier line x;
			      failwith "w-friendly"
		            end
			| TypeClash m ->
			    begin
			      Message.message#type_clash fichier line m;
			      failwith "w-friendly"
			    end	
                      in
                      Queue.add (line, EXTERNAL_BLOC (bloc_name, new_meth, string_args, arite_sortante_pipe), entrees, sorties) file_appel;
                      traite_pile ()	
              end
	  in   
	  match noeud with 
	  | NOEUD (line,a,b,c) ->
              begin
                (* fixme *)
		Stack.push (line,a,b,c) pile;
		traite_pile (); 
		list_init (fun _ -> check_end_desimbriq fichier (Queue.pop file_appel)) (Queue.length file_appel) 
              end
	  | _ -> failwith "Boucle : qui ne fait pas son travail ? (cdsmaker)"
	in
	tail_concat_map_rev appels_desimb_of_appel_imb corps
	  (* desimbriquer les boucles *)
	  (* On passe d'un (expr_arith param_net_variable) noeud list ---> variables_decorees noeud list *)
	  (* On decore un peu les types, pour y voir plus clair, sinon, c'est pas très lisible *)
      and expand_boucle_for_of_noeud_list fichier where_fonction liaisons liaisons_fonctionnelles (corps:(expr_arith param_net_variable list) Inputtools.noeud list) 
	  : variables_decorees Inputtools.noeud list = 
	(* Environnement fonctionnel du meme type que liaisons, pour concatener *)
	let environnement_fonctionnel = List.map (fun (ind, va) -> (ind, EnvString va)) liaisons_fonctionnelles in
	let decorer_net_variables new_liaisons appel_list =
	  let const_net_vars = const_net_vars_of_net_vars fichier new_liaisons appel_list in
	  (expand_net_var_list const_net_vars, const_net_vars)
	in
	let rec map_imb liaisons = function
	  | NET_VARS appel_list -> NET_VARS (decorer_net_variables liaisons appel_list)
	      (* FIXME : les meta evaluation ici !! sur le portee_noeud *)
	      (* FIXME : vu qu'on fait la meme chose plein de fois, il faut faire une fonction
		 qui s'appelle map_portee_noeud avec les arguments qui vont bien et l'appeler sur s.
		 Ca simpliefira beaucoup tous les matching de cette mega-non-meta-fonction *)
	  | IMB (ligne_imb, s, imb) -> 
	      begin
		let new_portee_noeud = 
		  match s with

		  (* Cas BEBOP imbrique *)
		  | BEBOP (call_imb_brut, parametres_list, arguments_fonctionnels_list) ->
		      begin
			let valeurs_parametres_list, valeurs_arguments_fonctionnels_list = 
			  try
			    List.map (eval_expr liaisons) parametres_list, 
			    List.map (eval_arg_fct (environnement_fonctionnel@liaisons)) arguments_fonctionnels_list
			  with
			  | SyntaxError com -> 
			      Message.message#string_arg_syntax_error fichier ligne_imb com;
			      failwith "w-friendly"
			  | FreeVar x ->   
			      begin
				Message.message#free_meta_var fichier ligne_imb x;
				failwith "w-friendly"
			      end
			  | TypeClash m ->
			      begin
				Message.message#type_clash fichier ligne_imb m;
				failwith "w-friendly"
			      end
			in
			BEBOP(call_imb_brut, List.map (fun va -> CST va) valeurs_parametres_list, List.map (fun va -> CONSTRUCTION va) valeurs_arguments_fonctionnels_list)
		      end
		  (* Cas PIPE imbrique *)
		  | PIPE (exe, exp_arit_nature) ->
		      begin
			let new_exe, arite_sortante_pipe = 
			  try
			    meta_commande liaisons exe, 
			    (
			      match exp_arit_nature with
			      | Resultat entier -> entier
			      | Calcul exp_arit -> eval_expr liaisons exp_arit
			      | Infere -> (* infere dans un imbrique *) 
				  (Message.message#pipe_imbrique_arite_probleme fichier ligne_imb exe; failwith "w-friendly")
			    )
			  with 
			  | SyntaxError com ->
			      begin
				Message.message#string_arg_syntax_error fichier ligne_imb com;
				failwith "w-friendly"
			      end
			  | FreeVar x ->   
			      begin
				Message.message#free_meta_var fichier ligne_imb x;
				failwith "w-friendly"
			      end
			  | TypeClash m ->
			      begin
				Message.message#type_clash fichier ligne_imb m;
				failwith "w-friendly"
			      end
			in
			PIPE (new_exe, (Resultat arite_sortante_pipe))
		      end

		  (* Cas external imbrique *)
		  | EXTERNAL_BLOC (bloc_name, meth, string_args, exp_arit_nature) ->
		      begin
			let new_meth, new_string_args, arite_sortante_external = 
			  try
			    (
			      match meth with
			      | None -> None
			      | Some m -> Some (ref (meta_commande liaisons (!m)))
			    ),
			    (
			      let f_map s = meta_commande liaisons s
			      in List.map f_map string_args
			    ),
			    (
			      match exp_arit_nature with
			      | Resultat entier -> entier
			      | Calcul exp_arit -> eval_expr liaisons exp_arit
			      | Infere -> (Message.message#external_imbrique_arite_probleme fichier ligne_imb bloc_name; failwith "w-friendly")
			    )
			  with 
			  | SyntaxError com ->
			      begin
				Message.message#commande_syntax_error fichier ligne_imb com;
				failwith "w-friendly"
			      end
			  | FreeVar x ->   
			      begin
				Message.message#free_meta_var fichier ligne_imb x;
				failwith "w-friendly"
			      end
			  | TypeClash m ->
			      begin
				Message.message#type_clash fichier ligne_imb m;
				failwith "w-friendly"
			      end
			in
			EXTERNAL_BLOC (bloc_name, new_meth, new_string_args, (Resultat arite_sortante_external))	
		      end
		in
		IMB (ligne_imb, new_portee_noeud, List.map (map_imb liaisons) imb)
	      end
	in 
	let rec map_noeud liaisons = function 	  
	  | NOEUD (line, BEBOP (call_brut, parametres_list, arguments_list), imb_list, appel_list) ->  
	      let valeurs_parametres, valeurs_arguments = 
		try
		  List.map (eval_expr liaisons) parametres_list,
		  List.map (eval_arg_fct (environnement_fonctionnel@liaisons)) arguments_list
		with
		| SyntaxError com -> 
		    Message.message#string_arg_syntax_error fichier line com;
		    failwith "w-friendly"
		| FreeVar x ->   
		    begin
		      Message.message#free_meta_var fichier line x;
		      failwith "w-friendly"
		    end
		| TypeClash m ->
		    begin
		      Message.message#type_clash fichier line m;
		      failwith "w-friendly"
		    end      
	      in
	      (* Au cas ou call_brut est un argument fonctionnel, il faut le remplacer par sa valeur effective *)
	      let prim = subst_fonctionnelle liaisons_fonctionnelles call_brut in
	      let real_name = concat_parametre_name prim valeurs_parametres valeurs_arguments in
	      begin
		if (StringMap.mem real_name table_arite_completee)
		  || (StringMap.mem real_name (!table_arite_sortante_fonctions))
		then ()(* c'est qu'il s'agit d'un appel non parametre, ou deja traite *)
		else 
		  (
		    match valeurs_parametres, valeurs_arguments with
		    | [], [] -> 
			begin
			  message#fct_non_declaree fichier line where_fonction prim;
			  failwith "w-friendly" 
			end
		    | _, _ ->
			begin
			  (* il faut specialiser *)
			  let spe = 
			    {
			      spe_fichier = fichier;
			      spe_liaisons = liaisons;
			      spe_line_appel = line;
			      spe_fct_appel = where_fonction;
			      spe_name = prim;
			      spe_valeurs_affectees_param = valeurs_parametres;
			      spe_valeurs_affectees_args_fcts = valeurs_arguments
			    }
			  in
			  specialiser_fonction_parametree spe
			end
		  );
		[ NOEUD (line, BEBOP (real_name,[], []),  
			 List.map (map_imb liaisons) imb_list,  
			 decorer_net_variables liaisons appel_list) ]
	      end
		
          | NOEUD (line, EXTERNAL_BLOC (bloc_name, meth, string_args, exp_arit_nature) , imb_list, appel_list) -> 
	      begin
		let new_meth =
		  match meth with
                  | None -> None
                  | Some m -> 
                      begin
			try
                          let eval_m = meta_commande liaisons (!m) in
                          Some (ref eval_m)
			with
			| SyntaxError com -> 
			    Message.message#commande_syntax_error fichier line com;
			    failwith "w-friendly"
			| FreeVar v ->
			    Message.message#free_meta_var fichier line v;
			    failwith "w-friendly"
			| TypeClash m -> 
			    Message.message#type_clash fichier line m;
			    failwith "w-friendly"
		      end   
                in
		let new_string_args =
		  let f_map s =
		    begin
		      try
			meta_commande liaisons s
		      with
		      | SyntaxError com -> 
			  Message.message#string_arg_syntax_error fichier line com;
			  failwith "w-friendly"
		      | FreeVar v ->
			  Message.message#free_meta_var fichier line v;
			  failwith "w-friendly"
		      | TypeClash m -> 
			  Message.message#type_clash fichier line m;
			  failwith "w-friendly"
		    end
		  in List.map f_map string_args
		in  
		[ NOEUD (line, EXTERNAL_BLOC (bloc_name, new_meth, new_string_args, exp_arit_nature), 
			 List.map (map_imb liaisons) imb_list, 
			 decorer_net_variables liaisons appel_list) ]
	      end
	  | NOEUD (line, PIPE (syscom, args), imb_list, appel_list) ->
	      (* FIXME : args ? *)
	      let new_syscom =
	      	begin
		  try
		    meta_commande liaisons syscom
		  with
		  | SyntaxError com -> 
		      Message.message#commande_syntax_error fichier line com;
		      failwith "w-friendly"
		  | FreeVar v ->
		      Message.message#free_meta_var fichier line v;
		      failwith "w-friendly"
		  | TypeClash m ->
		      Message.message#type_clash fichier line m;
		      failwith "w-friendly"
		end
	      in
              [ NOEUD (line, PIPE (new_syscom, args), 
                       List.map (map_imb liaisons) imb_list, 
                       decorer_net_variables liaisons appel_list) ]	
		
	  | NOEUD_COND (ligne, cond_expr, noeud_list_true, noeud_list_false) ->
	      let cond_eq =    
		try
		  eval_cond liaisons cond_expr
		with
		| FreeVar x -> 
		    begin
		      Message.message#free_meta_var fichier ligne x;
		      failwith "w-friendly"
		    end
		| TypeClash m ->
		    begin
		      Message.message#type_clash fichier ligne m;
		      failwith "w-friendly"
		    end
	      in
	      begin
		match cond_eq with
		| true -> tail_concat_map_rev (map_noeud liaisons) noeud_list_true
		| false -> tail_concat_map_rev (map_noeud liaisons) noeud_list_false
	      end
		
	  | BOUCLE_FOR (ligne, j, exp_inf, exp_sup, noeud_list) ->  
              (* capture de variables dans les boucles for *)
              if List.mem_assoc j liaisons 
              then Message.message#capture_indice fichier ligne j
              else ();
	      let inf, sup = 
		try 
		  (eval_expr liaisons exp_inf, eval_expr liaisons exp_sup)
		with 
		  | FreeVar x -> Message.message#free_meta_var fichier ligne x;failwith "w-friendly"
		  | TypeClash m -> Message.message#type_clash fichier ligne m; failwith "w-friendly"
	      in
	      let one_step index =  
		tail_concat_map_rev (map_noeud ((j,EnvInt index)::liaisons)) in 
	      let liste_iter = 
		if inf <= sup 
		then expand_list_croissant (fun t -> t) inf sup
		else expand_list_decroissant (fun t -> t) inf sup
	      in 
	      tail_concat_map_rev (fun i -> one_step i noeud_list) liste_iter
	in tail_concat_map_rev (map_noeud liaisons) corps
      
      and preprocess liaisons liaisons_fonctionnelles net_fonction =
	match net_fonction with
	| STANDARD one_fct_d ->
	    (* un peu de code bien tassé *)
	    let entrees_decorees = variables_decorees_of_net_var_list one_fct_d.fichier_dcl_f liaisons one_fct_d.entrees_dcl_f
	    and string_sorties, sorties_origine = variables_decorees_of_net_var_list one_fct_d.fichier_dcl_f liaisons one_fct_d.sorties_dcl_f 
	    and unused_decorees  = variables_decorees_of_net_var_list one_fct_d.fichier_dcl_f liaisons one_fct_d.unused_dcl_f 
	    and expand_corps   = expand_boucle_for_of_noeud_list one_fct_d.fichier_dcl_f one_fct_d.nom_dcl_f liaisons liaisons_fonctionnelles one_fct_d.corps_dcl_f in
	    let desimb_corps = corps_desimbrique_of_corps one_fct_d.fichier_dcl_f one_fct_d.nom_dcl_f liaisons liaisons_fonctionnelles expand_corps
	    in
	    begin
              (* prerr_endline (string_of_corps desimb_corps); *)
	      table_arite_sortante_fonctions := 
		StringMap.add one_fct_d.nom_dcl_f (List.length string_sorties) 
		  !table_arite_sortante_fonctions;
	      Stack.push
		{ (* FIXED : interface originale : variables_decorees *)
		  fichier_dcl_f = one_fct_d.fichier_dcl_f;
		  ligne_dcl_f = one_fct_d.ligne_dcl_f; 
		  attribut_dcl_f = one_fct_d.attribut_dcl_f;
		  nom_dcl_f = one_fct_d.nom_dcl_f;
		  entrees_dcl_f = entrees_decorees;
		  sorties_dcl_f = string_sorties, sorties_origine;
		  unused_dcl_f = unused_decorees;
		  corps_dcl_f = desimb_corps 
		}
		pile_des_fonctions
	    end
	| PARAMETREE dp ->
	    let parametres, arguments_fonctionnels, one_fct_d =
	      dp.dp_params_formels, dp.dp_args_fcts_formels, dp.dp_declaration in
            (* capture des macros avec les parametres *)
	    if StringMap.mem one_fct_d.nom_dcl_f (!fonctions_parametrees)
	    then Message.message#definition_multiple_parameter_net one_fct_d.fichier_dcl_f one_fct_d.ligne_dcl_f one_fct_d.nom_dcl_f
	    else
	      begin
		try
		  (* Verification des noms des parametres : pas de doublons *)
		  ignore (stringSet_of_list_distincts (List.map (fun (i,_) -> i) []) parametres);
		  (* Verification des noms des arguments optionnels : pas de doublons *)
		  ignore (stringSet_of_list_distincts [] arguments_fonctionnels);
		  (* Warning pour capture de variables *)
		  let f_iter j = 
		    if List.exists (fun (s, _) -> s = j) liaisons 
		    then Message.message#capture_indice one_fct_d.fichier_dcl_f one_fct_d.ligne_dcl_f j
		    else ()
		  in List.iter f_iter parametres
		with
		| NonDistincts x -> message#parametre_deja_lie one_fct_d.fichier_dcl_f one_fct_d.ligne_dcl_f one_fct_d.nom_dcl_f x
	      end;
	    (* ajout de la fonction dans la biblioteque de fonctions parametrees *)
	    fonctions_parametrees :=  
	      StringMap.add one_fct_d.nom_dcl_f dp (!fonctions_parametrees)
	| PARTIAL _ -> failwith "TODO partial app in cdsmaker"
      in 
      begin
	(* FIXED : l'axiome d'entree !! *)
	let assoc_tri_topo, _ = TriTopoGeneriqueFonction.tri_topo fcts_decl in
	let fcts_decl_tri_topo = List.map (fun (a, b) -> b) assoc_tri_topo in
	List.iter (preprocess macros []) fcts_decl_tri_topo;
	(* La pile est pleine, on la depile *)
	let fcts_debouclees = 
	  let rec aux accu = 
	    if Stack.is_empty pile_des_fonctions
	    then accu
	    else aux ((Stack.pop pile_des_fonctions)::accu)
	  in aux []
	in
	table_arite_completee, 
	{ 
	  y_main_module = module_name;
	  y_modules_bebop = !files_bebop;
	  y_memory_rom_tab = memory;
	  y_table_export_memoires = table_export_memoires;
	  y_externals_bloc_decl = externals_blocs_decl;
	  y_default_main = default_main;
	  y_fcts_debouclees = fcts_debouclees
	}
      end
(* ===================================================================== *)

(* ===================================================================== *)
let memory_and_env_of_file arite_primitive_initiale filename =
  let table_arite_completee, analyse = analyse_net_list arite_primitive_initiale filename in
  (analyse.y_memory_rom_tab, analyse.y_externals_bloc_decl, 
   (creer_environnement table_arite_completee analyse.y_default_main analyse.y_fcts_debouclees))
(* ===================================================================== *)

(* DEVELOPPEMENT DU CODE, BRISER LA HIERARCHIE *)

(* 
   la partie suivante vise a realiser un inline recursif de tous les appels
   de fonctions antérieures, avec substitution des parametres formels, 
   et en remplacant les variables locales par des freshs 
*)

(* 
   Preuve de la gestion des freshs : 
   On utilise des noms de la forme $int$ par incrementation
   le lexer interdit les identifiant qui commencent par $ 
*)

(* ===================================================================== *)
(** La transformation utilisee pour les freshs dans l'inline est 
    int -> string $int$. A ne pas confondre avec #int# qui est utilise
    dans la desimbrication*)  
(* ===================================================================== *)
let transf_fresh_inline = Printf.sprintf "$%d$"
(* ===================================================================== *)

(* ===================================================================== *)
(** Pour gerer une table AVL des aretes entre les noeuds du circuit 
    cf listMap.ml *)  
(* ===================================================================== *)
module StringListMap = ListMap.Make (StringOrder)
(* ===================================================================== *)

(* ===================================================================== *)
(** Comparaison d'entier optimisee a l'aide du pervasives *)  
(* ===================================================================== *)
let cmp_int (a:int) = Pervasives.compare a
(* ===================================================================== *)

(* ===================================================================== *)
(** Ordre lexicographique sur N * N avec pervasives*)  
(* ===================================================================== *)
let cmp2_int (a,b) (c,d) = 
  let res = cmp_int a c in
  if res = 0 
  then cmp_int b d
  else res
(* ===================================================================== *)

(* ===================================================================== *)
(** Diviser la tache en plusieurs sous-taches.
    On construit d'abord un pre-graphe, qui est un format simplifie
    a partir duquel on construit le cds brut (non trie topologiquement) *)
(* ===================================================================== *)
type pre_graphe =
{
  (* porte : prim * entrees * sorties *)
  portes : (primitif * string list * string list) array; 
  liaisons : (int * int) StringListMap.t;
  entrees : string list;
  sorties : string list
}
(* ===================================================================== *)

(* CONSTRUCTION DU PRE-GRAPHE A PARTIR DE L'ENVIRONNEMENT DES FONCTIONS *)

(* 

   On cree toutes les liaisons, et une file des noeuds en un parcours lineaire.  
   Preuve informelle :
   On raisonne par induction pour la validité du corps.
   
   A propos de la fonction de substitution :
   
   On a une partition des variables de la fonction appelée en : 
   - Variables d'entree
   - Variables de sortie
   - Variables locales.
   
   Cela correspond aux trois etapes de construction du stringMap
   utilise comme structure de bijection.

   La verification de typage (arite des fonctions) a deja ete fait
   avant cette etape, donc on est assure du fait que l'ent_list et la sort_list 
   ont la bonne longueur par rapport au champs de description de la 
   fonction appelée. Cela montre donc que l'exception LengthError 
   n'est jamais levée par le Double fold_left
*)

(*
  Une explication de la fonction ci-dessous est fournie dans le rapport 
  latex du projet 
*)

(* ===================================================================== *)
(** Creer le pre-graphe, a partir de l'environnement des fonctions de la
    net_list, et d'un axiome indiquant quelle est la fonction principale. 
    @param fresh_name une fonction de type fresh_maker
    @param main le nom de la fonction main, c'est l'axiome
    @param env l'environnement des fonctions 
    @return pg le pre-graphe correspondant *)
(* ===================================================================== *)
let creer_pre_graphe fresh_name main env =
  let des_main = StringMap.find main env in
  let file_noeud = Queue.create () (* Appellee file Q dans le rapport latex *)
  and fonctions_utilisees = ref StringSet.empty
  and index_noeud = ref 0 
  in
  let array_of_file_noeud () = 
    Array.init (Queue.length file_noeud) (fun _ -> Queue.pop file_noeud)
  in
  (* Fonction auxiliaire de substitution du corps d'une fonction anterieure 
     dont on donne la description des_ant, et les listes effectives 
     (ent_list, sort_list) rencontrees lors de l'appel de cette fonction *)
  let substitution_corps des_ant ent_list sort_list =
    let add_subst smap v_old v_new = StringMap.add v_old v_new smap in
    (* Substituer les entrees formelles par les parametres effectifs *)
    let etape1 = double_fold_left_list add_subst StringMap.empty 
      (des_ant.entrees_formelles, ent_list) in 
    (* Substituer les sorties formelles par les parametres effectifs *)
    let etape2 = double_fold_left_list add_subst etape1
      (des_ant.sorties_formelles, sort_list) in 
    (* Substituer les vas locales de la fonction appellée par des freshes *)
    (* ajoutons autant de freshs que de variables locales *)
    let transf_map = 
      List.fold_left (fun smap v -> StringMap.add v (fresh_name ()) smap) etape2 
	des_ant.variables_locales in
    let subst v = 
      try
	StringMap.find v transf_map
      with
      | Not_found -> failwith "Pas possible apres l'analyse proof"
         (* cf commentaire ci-dessus : partition des variables de la fonction *)
    in
    begin
      fonctions_utilisees := StringSet.add des_ant.name (!fonctions_utilisees);
      List.map (fun (f, el, sl) -> (f, List.map subst el, List.map subst sl))
	des_ant.corps
    end 
  in
  (* Parcours en profondeur dans l'environnement des fonctions, 
     dans un graphe qu'on pourrait appeler le graphe de dependance 
     fonctionnelle de la net-list.
     -Modifie file_noeud par effet de bord, 
     -recolte les liaisons necessaires au branchement correct de tous les fils *)
  let liaisons = 
    (* La fonction TRAITE figurant dans le rapport latex.
       Cette fonction travaille par induction sur les listes d'appels des corps. 
       Elle renvoit la table des liaisons *)
    let rec _TRAITE accu = function
      | [] -> accu
      | (Prim pr, ent_list, sort_list)::q -> 
	  begin
	    (* Ajouter dans la table les liaisons (var -> (INDEX, comp) *)
	    (* CF rapport latex, substitution recursive des appels *)
	    let new_accu = 
	      let rec visite_entree accu i = function
		| [] -> accu
		| t::q -> 
		    visite_entree 
		      (StringListMap.add cmp2_int t (!index_noeud,i) accu) 
		      (succ i) q
	      in visite_entree accu 0 ent_list
	    in
	    begin
	      incr(index_noeud); (* incrementer INDEX *)
	      Queue.add (pr, ent_list, sort_list) file_noeud; 
	      _TRAITE new_accu q
	    end
	  end 
      | (FctAnt name, ent_list, sort_list)::q ->
	  begin
	    let des_ant = StringMap.find name env in
	    let new_corps = 
	      substitution_corps des_ant ent_list sort_list in
	    (* remonte d'abord dans l'inline en profondeur *)
	    let new_accu = _TRAITE accu new_corps in
	    (* puis continue son travail *)
	    _TRAITE new_accu q
	  end
    in (message#inline_functions; _TRAITE StringListMap.empty des_main.corps)
  in
  begin
    (* relever les fonctions inutilisees de la net-list *)
    let verif name fd = 
      if (name=main)||(StringSet.mem name (!fonctions_utilisees))
      then () 
      else 
	if (String.compare fd.fichier des_main.fichier = 0)
	then message#fonction_inutile fd.fichier name
	else ()
    in StringMap.iter verif env;

    (* vider la file Q, rendre le pre-graphe *)
    {
      portes = array_of_file_noeud ();
      liaisons = liaisons;
      entrees = des_main.entrees_formelles;
      sorties = des_main.sorties_formelles
    }
  end 
(* ===================================================================== *)

(* ===================================================================== *)
(** Le Pre-graphe etant fait, on peut passer a la construction du  cds brut
    @param d le pre-graphe d'un circuit
    @return cds_brut le cds non trié topologiquement *)
(* ===================================================================== *)
let cds_brut_of_pre_graphe d = 
  let n = Array.length d.portes in
  let tab_entrees = Array.of_list d.entrees in
  let nb_entrees = Array.length tab_entrees in
  let tab_sorties = Array.of_list d.sorties in
  let nb_sorties = Array.length tab_sorties in
  (* 
     Comme on ajoute un noeud Input en 0, on doit decaler les indices 
     dans les liaisons.
     On doit de plus creer les liaisons occasionnées par l'ajout des 
     noeuds Input et Output.
  *)
  let ajoute_output liaisons = 
    let rec aux accu i = function
      | [] -> accu
      | t::q -> aux (StringListMap.add cmp2_int t (n+1,i) accu) (succ i) q 
    in aux liaisons 0 d.sorties
  in
  let incremente_index = StringListMap.map (fun (i,c) -> (succ i,c)) in
  let new_liaisons = ajoute_output (incremente_index d.liaisons) in
  let construction_noeud i = 
    begin
      if i = 0 (* NOEUD INPUT : ses sorties sont les entrees du circuit *)
      then
	{
	  entree = [||];
	  sortie = Array.make nb_entrees false;
	  voisins = Array.init nb_entrees 
	    (fun j -> StringListMap.find tab_entrees.(j) new_liaisons);
	  noeud_type = Input;
	}
      else
	if i = n + 1 (* NOEUD OUTPUT : ses entrees sont les sorties du circuit *)
	then
	  {
	    entree = Array.make nb_sorties false;
	    sortie = [||];
	    voisins = [||];
	    noeud_type = Output;
	  }
	else
          (* 
             le test d'arite etant passé, l'allocation des tableaux est correcte
             en fonction du type primitif des noeuds.
	     On distingue les primitifs Clock, Vdd dont les sorties doivent etre 
	     initialises a true contrairement aux autres primitifs.
	     Pour ce qui est des Registres, cela est fait dans split_registers
	     dans circuit.ml
          *)
	  match d.portes.(pred i) with
	  | cl_vdd, ent, sort when cl_vdd = Clock || cl_vdd = Vdd ->
	      {
		entree = [||];
		sortie = [|true|];
		voisins = [|StringListMap.find (List.hd sort) new_liaisons|];
		noeud_type = cl_vdd;
	      }
          | reg_nreg, ent, sort when reg_nreg = Reg || reg_nreg = NReg ->
              {
                entree = [|false;true|]; 
		(* ci-dessus : par defaut, l'enable des registres est a 1 *)
                sortie = [||]; 
		(* ci-dessus : cette sortie ne sera pas conservée (split reg)*)
                voisins = [|StringListMap.find (List.hd sort) new_liaisons|];
                noeud_type = reg_nreg;
              }
	  | prim, ent, sort  ->
	      let tab_sorties_noeud = Array.of_list sort in
	      let nb_sorties_noeud = Array.length tab_sorties_noeud in
	      {
		entree = Array.make (List.length ent) false;
		sortie = Array.make nb_sorties_noeud false;
		voisins = Array.init nb_sorties_noeud
		(fun j -> StringListMap.find tab_sorties_noeud.(j) new_liaisons);
		noeud_type = prim;
	      }
    end
  in 
  begin
    message#cds_brut;
    Array.init (n+2) construction_noeud
  end
(* ===================================================================== *)

(* ===================================================================== *)
(** Nouveauté version 1.0.1 -> optimisation sur le format machine virtuelle 
    On enleve les primitives Gnd, Vdd, Id. On fait de l'evaluation partielle. 
    On enleve tout ce qui est calcul inutile *)
(* ===================================================================== *)
let optimised_cds cds = cds (* OptimiseCds.optimise cds *)
(* ===================================================================== *)  

(* ===================================================================== *)
(** Recapitulatif des etapes parcourues depuis le nom du fichier net_list
    jusqu'a un objet de type class circuit : Passing style fonctionnel 
    @param filename le nom du fichier net list
    @return circuit un objet de class circuit *)
(* ===================================================================== *)
let circuit_final_of_net_list filename =
  let primitive_initiale = arite_primitive_initiale () in 
  let (rom_memory_tab, blocs_externes, (env, axiome)) = 
    memory_and_env_of_file primitive_initiale filename in
  let (fresh_name, _ ) = fresh_fct_factory transf_fresh_inline in
  let pre_graphe =  creer_pre_graphe fresh_name axiome env in
  let cds_brut = cds_brut_of_pre_graphe pre_graphe in
  let cds_final = split_registers cds_brut in
  begin
    (
      if detect_cycle cds_final
      then 
	begin
	  (* On donne sur stdout les indications pour essayer de localiser le cycle *)
	  Printf.fprintf stdout "Erreur : Indications pour localiser le cycle : \n\n"; 
	  Queue.iter print_endline indications_cycle; 
	  Message.message#cycle
	end
      else ()
    );
    tri_topo cds_final;
    let cds_optimised = optimised_cds cds_final in
    let des_main = StringMap.find axiome env in
    begin
      Message.message#cds_final ((Array.length cds_optimised)-2) (transistors_of_circuit cds_optimised);
      message#creation_objet;
      new circuit filename des_main.name cds_optimised rom_memory_tab blocs_externes
        des_main.entrees_formelles 
	des_main.sorties_formelles
    end
  end
(* ===================================================================== *)


(* ===================================================================== *)
(** Recapitulatif des etapes parcourues depuis le nom du fichier net_list
    jusqu'au donnees serialisable permettant de reconstruire le circuit
    plus tard. (format proprietaire bebop : bpx = values ocaml)
    @param filename le nom du fichier net list
    @return args les arguments du constructeur new circuit *)
(* ===================================================================== *)
let serialisation_of_net_list filename =
  let primitive_initiale = arite_primitive_initiale () in 
  let (rom_memory_tab, blocs_externes, (env, axiome)) = 
    memory_and_env_of_file primitive_initiale filename in
  let (fresh_name, _ ) = fresh_fct_factory transf_fresh_inline in
  let pre_graphe =  creer_pre_graphe fresh_name axiome env in
  let cds_brut = cds_brut_of_pre_graphe pre_graphe in
  let cds_final = split_registers cds_brut in
  begin
    (
      if detect_cycle cds_final
      then 
	begin
	  (* On donne sur stdout les indications pour essayer de localiser le cycle *)
	  Queue.iter print_endline indications_cycle; 
	  Message.message#cycle
	end
      else ()
    );
    tri_topo cds_final; 
    let cds_optimised = optimised_cds cds_final in
    let des_main = StringMap.find axiome env in
    begin
      Message.message#cds_final ((Array.length cds_optimised)-2) (transistors_of_circuit cds_optimised);
      (filename, des_main.name, cds_optimised,rom_memory_tab, blocs_externes, des_main.entrees_formelles, des_main.sorties_formelles)
    end
  end
(* ===================================================================== *)

exception Mauvais_Format

(* ===================================================================== *)
(** On produit une chaine d'identification pour voir si les bpx en sont 
    bien (la premiere value est une chaine de caractere) *)
(* ===================================================================== *)
let ident_bpx = "bebop circuit bpx"
(* ===================================================================== *)

(* ===================================================================== *)
(** Reformer la serialisation a partir d'un fichier bpx *)
(* ===================================================================== *)
let serialisation_of_bpx_file filename =
  try
    Message.message#chargement_circuit_compile filename;
    let ic = open_in filename in
    let ident = input_value ic in
    if ident <> ident_bpx
    then (close_in ic; raise Mauvais_Format)
    else
      begin
        let filename = input_value ic
        and axiome_name = input_value ic
	and cds_final = input_value ic
	and rom_memory_tab = input_value ic
        and blocs_externes = input_value ic
	and entrees_formelles = input_value ic
	and sorties_formelles = input_value ic in
	close_in ic;
	filename, axiome_name, cds_final, rom_memory_tab, blocs_externes, entrees_formelles, sorties_formelles
      end
  with
  | Sys_error _ ->
      Message.message#circuit_compile_introuvable filename;
      failwith "w-friendly"
  | Mauvais_Format | Failure "input_value: bad object" -> 
      Message.message#mauvais_format_circuit_compile filename;
      failwith "w-friendly"
(* ===================================================================== *)
